home *** CD-ROM | disk | FTP | other *** search
/ PC-X 1997 October / pcx14_9710.iso / swag / delphi.swg / 0009_Serial Communication.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-11-22  |  12.0 KB  |  479 lines
  1.  
  2. {
  3. Someone was looking for a serial communication control, I just don't
  4. quite remember who it was.  Hopefully this code will help him/her..
  5. }
  6. unit Comm;
  7.  
  8. interface
  9.  
  10. uses
  11.   Messages,WinTypes,WinProcs,Classes,Excepts,Forms,MsgDlg;
  12.  
  13. type
  14.   TPort=(tptNone,tptOne,tptTwo,tptThree,tptFour,tptFive,
  15.          tptSix,tptSeven,tptEight);
  16.  
  17.   TBaudRate=(tbr110,tbr300,tbr600,tbr1200,tbr2400,tbr4800,tbr9600,
  18.              tbr14400,tbr19200,tbr38400,tbr56000,tbr128000,
  19.              tbr256000);
  20.  
  21.   TParity=(tpNone,tpOdd,tpEven,tpMark,tpSpace);
  22.  
  23.   TDataBits=(tdbFour,tdbFive,tdbSix,tdbSeven,tdbEight);
  24.  
  25.   TStopBits=(tsbOne,tsbOnePointFive,tsbTwo);
  26.  
  27.   TCommEvent=(tceBreak,tceCts,tceCtss,tceDsr,tceErr,tcePErr,
  28.               tceRing,tceRlsd,tceRlsds,tceRxChar,tceRxFlag,
  29.               tceTxEmpty);
  30.  
  31.   TCommEvents=set of TCommEvent;
  32.  
  33. const
  34.   PortDefault=tptNone;
  35.   BaudRateDefault=tbr9600;
  36.   ParityDefault=tpNone;
  37.   DataBitsDefault=tdbEight;
  38.   StopBitsDefault=tsbOne;
  39.   ReadBufferSizeDefault=2048;
  40.   WriteBufferSizeDefault=2048;
  41.   RxFullDefault=1024;
  42.   TxLowDefault=1024;
  43.   EventsDefault=[];
  44.  
  45. type
  46.   TNotifyEventEvent=
  47.     procedure(Sender:TObject;CommEvent:TCommEvents) of object;
  48.  
  49.   TNotifyReceiveEvent=
  50.     procedure(Sender:TObject;Count:Word) of object;
  51.  
  52.   TNotifyTransmitEvent=
  53.     procedure(Sender:TObject;Count:Word) of object;
  54.  
  55.   TComm=class(TComponent)
  56.   private
  57.     FPort:TPort;
  58.     FBaudRate:TBaudRate;
  59.     FParity:TParity;
  60.     FDataBits:TDataBits;
  61.     FStopBits:TStopBits;
  62.     FReadBufferSize:Word;
  63.     FWriteBufferSize:Word;
  64.     FRxFull:Word;
  65.     FTxLow:Word;
  66.     FEvents:TCommEvents;
  67.     FOnEvent:TNotifyEventEvent;
  68.     FOnReceive:TNotifyReceiveEvent;
  69.     FOnTransmit:TNotifyTransmitEvent;
  70.     FWindowHandle:hWnd;
  71.     hComm:Integer;
  72.     HasBeenLoaded:Boolean;
  73.     Error:Boolean;
  74.     procedure SetPort(Value:TPort);
  75.     procedure SetBaudRate(Value:TBaudRate);
  76.     procedure SetParity(Value:TParity);
  77.     procedure SetDataBits(Value:TDataBits);
  78.     procedure SetStopBits(Value:TStopBits);
  79.     procedure SetReadBufferSize(Value:Word);
  80.     procedure SetWriteBufferSize(Value:Word);
  81.     procedure SetRxFull(Value:Word);
  82.     procedure SetTxLow(Value:Word);
  83.     procedure SetEvents(Value:TCommEvents);
  84.     procedure WndProc(var Msg:TMessage);
  85.     procedure DoEvent;
  86.     procedure DoReceive;
  87.     procedure DoTransmit;
  88.   protected
  89.     procedure Loaded;override;
  90.   public
  91.     constructor Create(AOwner:TComponent);override;
  92.     destructor Destroy;override;
  93.     procedure Write(Data:PChar;Len:Word);
  94.     procedure Read(Data:PChar;Len:Word);
  95.     function IsError:Boolean;
  96.   published
  97.     property Port:TPort
  98.       read FPort write SetPort default PortDefault;
  99.     property BaudRate:TBaudRate read FBaudRate write SetBaudRate
  100.       default BaudRateDefault;
  101.     property Parity:TParity read FParity write SetParity
  102.       default ParityDefault;
  103.     property DataBits:TDataBits read FDataBits write SetDataBits
  104.       default DataBitsDefault;
  105.     property StopBits:TStopBits read FStopBits write SetStopBits
  106.       default StopBitsDefault;
  107.     property WriteBufferSize:Word read FWriteBufferSize
  108.       write SetWriteBufferSize default WriteBufferSizeDefault;
  109.     property ReadBufferSize:Word read FReadBufferSize
  110.       write SetReadBufferSize default ReadBufferSizeDefault;
  111.     property RxFullCount:Word read FRxFull write SetRxFull
  112.       default RxFullDefault;
  113.     property TxLowCount:Word read FTxLow write SetTxLow
  114.       default TxLowDefault;
  115.     property Events:TCommEvents read FEvents write SetEvents
  116.       default EventsDefault;
  117.     property OnEvent:TNotifyEventEvent read FOnEvent
  118.       write FOnEvent;
  119.     property OnReceive:TNotifyReceiveEvent read FOnReceive
  120.       write FOnReceive;
  121.     property OnTransmit:TNotifyTransmitEvent
  122.       read FOnTransmit write FOnTransmit;
  123.   end;
  124.  
  125. procedure Register;
  126.  
  127. implementation
  128.  
  129. procedure TComm.SetPort(Value:TPort);
  130. const
  131.   CommStr:PChar='COM1:';
  132. begin
  133.   FPort:=Value;
  134.   if (csDesigning in ComponentState) or
  135.      (Value=tptNone) or (not HasBeenLoaded) then exit;
  136.   if hComm>=0 then CloseComm(hComm);
  137.   CommStr[3]:=chr(48+ord(Value));
  138.   hComm:=OpenComm(CommStr,ReadBufferSize,WriteBufferSize);
  139.   if hComm<0 then
  140.   begin
  141.     Error:=True;
  142.     exit;
  143.   end;
  144.   SetBaudRate(FBaudRate);
  145.   SetParity(FParity);
  146.   SetDataBits(FDataBits);
  147.   SetStopBits(FStopBits);
  148.   SetEvents(FEvents);
  149.   EnableCommNotification(hComm,FWindowHandle,FRxFull,FTxLow);
  150. end;
  151.  
  152. procedure TComm.SetBaudRate(Value:TBaudRate);  
  153. var
  154.   DCB:TDCB;  
  155. begin
  156.   FBaudRate:=Value;
  157.   if hComm>=0 then
  158.   begin
  159.     GetCommState(hComm,DCB);
  160.     case Value of
  161.       tbr110:
  162.         DCB.BaudRate:=CBR_110;
  163.       tbr300:
  164.         DCB.BaudRate:=CBR_300;
  165.       tbr600:
  166.         DCB.BaudRate:=CBR_600;
  167.       tbr1200:
  168.         DCB.BaudRate:=CBR_1200;
  169.       tbr2400:
  170.         DCB.BaudRate:=CBR_2400;
  171.       tbr4800:
  172.         DCB.BaudRate:=CBR_4800;
  173.       tbr9600:
  174.         DCB.BaudRate:=CBR_9600;
  175.       tbr14400:
  176.         DCB.BaudRate:=CBR_14400;
  177.       tbr19200:
  178.         DCB.BaudRate:=CBR_19200;
  179.       tbr38400:
  180.         DCB.BaudRate:=CBR_38400;
  181.       tbr56000:
  182.         DCB.BaudRate:=CBR_56000;
  183.       tbr128000:
  184.         DCB.BaudRate:=CBR_128000;
  185.       tbr256000:
  186.         DCB.BaudRate:=CBR_256000;
  187.     end;
  188.     SetCommState(DCB);
  189.   end;
  190. end;
  191.  
  192. procedure TComm.SetParity(Value:TParity);  
  193. var
  194.   DCB:TDCB;
  195. begin
  196.   FParity:=Value;
  197.   if hComm<0 then exit;
  198.   GetCommState(hComm,DCB);
  199.   case Value of
  200.     tpNone:
  201.       DCB.Parity:=0;
  202.     tpOdd:
  203.       DCB.Parity:=1;
  204.     tpEven:
  205.       DCB.Parity:=2;
  206.     tpMark:
  207.       DCB.Parity:=3;
  208.     tpSpace:
  209.       DCB.Parity:=4;
  210.   end;
  211.   SetCommState(DCB);  
  212. end;  
  213.  
  214. procedure TComm.SetDataBits(Value:TDataBits);
  215. var
  216.   DCB:TDCB;  begin
  217.   FDataBits:=Value;
  218.   if hComm<0 then exit;
  219.   GetCommState(hComm,DCB);
  220.   case Value of
  221.     tdbFour:
  222.       DCB.ByteSize:=4;
  223.     tdbFive:
  224.       DCB.ByteSize:=5;
  225.     tdbSix:
  226.       DCB.ByteSize:=6;
  227.     tdbSeven:
  228.       DCB.ByteSize:=7;
  229.     tdbEight:
  230.       DCB.ByteSize:=8;
  231.   end;
  232.   SetCommState(DCB);
  233. end;
  234.  
  235. procedure TComm.SetStopBits(Value:TStopBits);
  236. var
  237.   DCB:TDCB;  
  238. begin
  239.   FStopBits:=Value;
  240.   if hComm<0 then exit;
  241.   GetCommState(hComm,DCB);
  242.   case Value of
  243.     tsbOne:
  244.       DCB.StopBits:=0;
  245.     tsbOnePointFive:
  246.       DCB.StopBits:=1;
  247.     tsbTwo:
  248.       DCB.StopBits:=2;
  249.   end;
  250.   SetCommState(DCB);  
  251. end;
  252.  
  253. procedure TComm.SetReadBufferSize(Value:Word);
  254. begin
  255.   FReadBufferSize:=Value;
  256.   SetPort(FPort);  
  257. end;  
  258.  
  259. procedure TComm.SetWriteBufferSize(Value:Word);
  260. begin
  261.   FWriteBufferSize:=Value;
  262.   SetPort(FPort);  
  263. end;  
  264.  
  265. procedure TComm.SetRxFull(Value:Word);  
  266. begin
  267.   FRxFull:=Value;
  268.   if hComm<0 then exit;
  269.   EnableCommNotification(hComm,FWindowHandle,FRxFull,FTxLow);  
  270. end;
  271.  
  272. procedure TComm.SetTxLow(Value:Word);  
  273. begin
  274.   FTxLow:=Value;
  275.   if hComm<0 then exit;
  276.   EnableCommNotification(hComm,FWindowHandle,FRxFull,FTxLow);  
  277. end;
  278.  
  279. procedure TComm.SetEvents(Value:TCommEvents);  
  280. var
  281.   EventMask:Word;  
  282. begin
  283.   FEvents:=Value;
  284.   if hComm<0 then exit;
  285.   EventMask:=0;
  286.   if tceBreak in FEvents then inc(EventMask,EV_BREAK);
  287.   if tceCts in FEvents then inc(EventMask,EV_CTS);
  288.   if tceCtss in FEvents then inc(EventMask,EV_CTSS);
  289.   if tceDsr in FEvents then inc(EventMask,EV_DSR);
  290.   if tceErr in FEvents then inc(EventMask,EV_ERR);
  291.   if tcePErr in FEvents then inc(EventMask,EV_PERR);
  292.   if tceRing in FEvents then inc(EventMask,EV_RING);
  293.   if tceRlsd in FEvents then inc(EventMask,EV_RLSD);
  294.   if tceRlsds in FEvents then inc(EventMask,EV_RLSDS);
  295.   if tceRxChar in FEvents then inc(EventMask,EV_RXCHAR);
  296.   if tceRxFlag in FEvents then inc(EventMask,EV_RXFLAG);
  297.   if tceTxEmpty in FEvents then inc(EventMask,EV_TXEMPTY);
  298.   SetCommEventMask(hComm,EventMask);  
  299. end;  
  300.  
  301. procedure TComm.WndProc(var Msg:TMessage);  
  302. begin
  303.   with Msg do
  304.   begin
  305.     if Msg=WM_COMMNOTIFY then
  306.     begin
  307.       case lParamLo of
  308.         CN_EVENT:
  309.           DoEvent;
  310.         CN_RECEIVE:
  311.           DoReceive;
  312.         CN_TRANSMIT:
  313.           DoTransmit;
  314.       end;
  315.     end
  316.     else
  317.       Result:=DefWindowProc(FWindowHandle,Msg,wParam,lParam);
  318.   end;  
  319. end;  
  320.  
  321. procedure TComm.DoEvent;
  322. var
  323.   CommEvent:TCommEvents;
  324.   EventMask:Word;
  325. begin
  326.   if (hComm<0) or not Assigned(FOnEvent) then exit;
  327.   EventMask:=GetCommEventMask(hComm,Integer($FFFF));
  328.   CommEvent:=[];
  329.   if (tceBreak in Events) and (EventMask and EV_BREAK<>0) then
  330.     CommEvent:=CommEvent+[tceBreak];
  331.   if (tceCts in Events) and (EventMask and EV_CTS<>0) then
  332.     CommEvent:=CommEvent+[tceCts];
  333.   if (tceCtss in Events) and (EventMask and EV_CTSS<>0) then
  334.     CommEvent:=CommEvent+[tceCtss];
  335.   if (tceDsr in Events) and (EventMask and EV_DSR<>0) then
  336.     CommEvent:=CommEvent+[tceDsr];
  337.   if (tceErr in Events) and (EventMask and EV_ERR<>0) then
  338.     CommEvent:=CommEvent+[tceErr];
  339.   if (tcePErr in Events) and (EventMask and EV_PERR<>0) then
  340.     CommEvent:=CommEvent+[tcePErr];
  341.   if (tceRing in Events) and (EventMask and EV_RING<>0) then
  342.     CommEvent:=CommEvent+[tceRing];
  343.   if (tceRlsd in Events) and (EventMask and EV_RLSD<>0) then
  344.     CommEvent:=CommEvent+[tceRlsd];
  345.   if (tceRlsds in Events) and (EventMask and EV_Rlsds<>0) then
  346.     CommEvent:=CommEvent+[tceRlsds];
  347.   if (tceRxChar in Events) and (EventMask and EV_RXCHAR<>0) then
  348.     CommEvent:=CommEvent+[tceRxChar];
  349.   if (tceRxFlag in Events) and (EventMask and EV_RXFLAG<>0) then
  350.     CommEvent:=CommEvent+[tceRxFlag];
  351.   if (tceTxEmpty in Events) and (EventMask and EV_TXEMPTY<>0) then
  352.     CommEvent:=CommEvent+[tceTxEmpty];
  353.   FOnEvent(Self,CommEvent);  
  354. end;  
  355.  
  356. procedure TComm.DoReceive;  
  357. var
  358.   Stat:TComStat;  
  359. begin
  360.   if (hComm<0) or not Assigned(FOnReceive) then exit;
  361.   GetCommError(hComm,Stat);
  362.   FOnReceive(Self,Stat.cbInQue);
  363. end;  
  364.  
  365. procedure TComm.DoTransmit;
  366. var
  367.   Stat:TComStat;  
  368. begin
  369.   if (hComm<0) or not Assigned(FOnTransmit) then exit;
  370.   GetCommError(hComm,Stat);
  371.   FOnTransmit(Self,Stat.cbOutQue);  
  372. end;  
  373.  
  374. procedure TComm.Loaded;
  375. begin
  376.   inherited Loaded;
  377.   HasBeenLoaded:=True;
  378.   SetPort(FPort);
  379. end;  
  380.  
  381. constructor TComm.Create(AOwner:TComponent);
  382. begin
  383.   inherited Create(AOwner);
  384.   FWindowHandle:=AllocateHWnd(WndProc);
  385.   HasBeenLoaded:=False;
  386.   Error:=False;
  387.   FPort:=PortDefault;
  388.   FBaudRate:=BaudRateDefault;
  389.   FParity:=ParityDefault;
  390.   FDataBits:=DataBitsDefault;
  391.   FStopBits:=StopBitsDefault;
  392.   FWriteBufferSize:=WriteBufferSizeDefault;
  393.   FReadBufferSize:=ReadBufferSizeDefault;
  394.   FRxFull:=RxFullDefault;
  395.   FTxLow:=TxLowDefault;
  396.   FEvents:=EventsDefault;
  397.   hComm:=-1;
  398. end;  
  399.  
  400. destructor TComm.Destroy;
  401. begin
  402.   DeallocatehWnd(FWindowHandle);
  403.   if hComm>=0 then CloseComm(hComm);
  404.   inherited Destroy;
  405. end;  
  406.  
  407. procedure TComm.Write(Data:PChar;Len:Word);
  408. begin
  409.   if hComm<0 then exit;
  410.   if WriteComm(hComm,Data,Len)<0 then Error:=True;  
  411. end;  
  412.  
  413. procedure TComm.Read(Data:PChar;Len:Word);  
  414. begin
  415.   if hComm<0 then exit;
  416.   if ReadComm(hComm,Data,Len)<0 then Error:=True;
  417. end;  
  418.  
  419. function TComm.IsError:Boolean;
  420. begin
  421.   IsError:=Error;
  422.   Error:=False;
  423. end;
  424.  
  425. procedure Register;
  426. begin
  427.   RegisterComponents('Additional',[TComm]);
  428. end;
  429.  
  430. end.
  431.  
  432. {------------------------------------------------------------------------------}
  433.  
  434. unit Main;  
  435.  
  436. interface 
  437.  
  438. uses
  439.   Messages,WinTypes, WinProcs, Classes,
  440.   Graphics, Forms, Controls,StdCtrls, Comm;  
  441.  
  442. type
  443.   TForm1 = class(TForm)
  444.     Memo1: TMemo;
  445.     Comm1: TComm;
  446.     procedure Memo1KeyPress(Sender: TObject; var Key: Char);
  447.     procedure Comm1Receive(Sender: TObject; Count: Word);
  448.   end;  
  449.  
  450. var
  451.   Form1: TForm1;
  452.  
  453. implementation 
  454.  
  455. {$R *.FRM}
  456.  
  457. procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
  458. begin
  459.   Comm1.Write(@Key,SizeOf(Key));
  460. end;
  461.  
  462. procedure TForm1.Comm1Receive(Sender: TObject; Count: Word);
  463. var
  464.   CommChar:Char;
  465.   i:Word;
  466. begin
  467.   for i:=1 to Count do
  468.   begin
  469.     Comm1.Read(@CommChar,SizeOf(CommChar));
  470.     PostMessage(Memo1.Handle,WM_CHAR,Word(CommChar),0);
  471.   end;
  472. end;
  473.  
  474. begin
  475.   RegisterClasses([TForm1, TMemo, TComm]);
  476.   Form1 := TForm1.Create(Application);
  477. end.
  478.  
  479.